perm filename INITIA[MAC,LSP]1 blob
sn#404899 filedate 1978-12-17 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00011 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00004 00003
C00014 00004
C00017 00005
C00022 00006
C00026 00007
C00031 00008
C00036 00009
C00040 00010
C00044 00011
C00047 ENDMK
C⊗;
;;; -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ***** INITIA (Initialization for COMPLR) *******
;;; **************************************************************
;;; ** (C) Copyright 1978 Massachusetts Institute of Technology **
;;; ****** This is a Read-Only file! (All writes reserved) *******
;;; **************************************************************
(EVAL-WHEN (COMPILE) (INCLUDE ((DSK COMLAP) CDMACS >)))
(EVAL-WHEN (COMPILE) (COMPDECLARE) (FASLDECLARE) (GENPREFIX |/|in|) )
(SETQ INITIAVERNO '##(COND ((CADDR (TRUENAME INFILE)))
('/3)))
(REMPROP 'EVAL-WHEN 'FSUBR)
(AND (NOT (STATUS FEATURE SAIL))
(NOT (GET 'EREAD 'FSUBR))
(PUTPROP 'EREAD (GET 'UREAD 'FSUBR) 'FSUBR))
(COMMENT INITIALIZING FUNCTIONS)
(DEFUN INITIALIZE FEXPR (L)
(SSTATUS FEATURE COMPLR)
(SSTATUS FEATURE NCOMPLR)
(SETQ OPSYS (COND ((STATUS FEATURE ITS) 'ITS )
((STATUS FEATURE SAIL) 'SAIL)
((STATUS FEATURE DEC20) 'DEC20)
((STATUS FEATURE DEC10) 'DEC10)
((BARF () |WHAT OPERATING SYSTEM?|))))
(SETQ OBARRAY (SETQ SOBARRAY (GET 'OBARRAY 'ARRAY)))
(SETQ READTABLE (SETQ SREADTABLE (GET 'READTABLE 'ARRAY)))
(SETQ MAKLAP-DEFAULTF-STYLE 'MIDAS)
(SETQ SWITCHTABLE ;Setup before INTERNing
(APPEND '(
(/$ FLOSW ()) (/+ FIXSW ())
(A ASSEMBLE () ) (C CLOSED () )
(D DISOWNED () ) (E EXPR-HASH () )
(F FASL ##(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(G GAG-ERRBREAKS () ) (H EXPAND-OUT-MACROS T)
(I INITIALIZE () )
(K NOLAP ##(AND (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) T))
(M MACROS () ) (O ARRAYOPEN T) (S SPECIALS () )
(T TTYNOTES ##(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T))
(W MUZZLED () ) (X MAPEX () )
(Y YESWARNTTY ##(AND (NOT (MEMQ COMPILER-STATE
'(MAKLAP DECLARE))) T) )
(Z SYMBOLS () )
)
()))
(PUSH (COND (#(SAILP)
(SETQ MAKLAP-DEFAULTF-STYLE () )
'(U UNFASLCOMMENTS () ))
( '(U UNFASLCOMMENTS T)))
SWITCHTABLE)
(DO I 65. (1+ I) (> I 90.)
(AND (NOT (ASSQ (ASCII I) SWITCHTABLE))
(PUSH (LIST (ASCII I)
(IMPLODE (APPEND '(S W I T C H /-) (LIST (ASCII I))))
() )
SWITCHTABLE)))
(COND ((STATUS FEATURE NO-EXTRA-OBARRAY)
(SETQ CREADTABLE READTABLE COBARRAY OBARRAY))
('T (SETQ CREADTABLE (COND ((AND (BOUNDP 'IREADTABLE)
(EQ (TYPEP IREADTABLE) 'ARRAY)
(EQ (CAR (ARRAYDIMS IREADTABLE))
'READTABLE))
IREADTABLE)
('T)))
(SETQ CREADTABLE (ARRAY () READTABLE CREADTABLE))
(SETQ COBARRAY (COND ((AND (BOUNDP 'IOBARRAY)
(EQ (TYPEP IOBARRAY) 'ARRAY)
(EQ (CAR (ARRAYDIMS IOBARRAY))
'OBARRAY))
IOBARRAY)
((GET 'OBARRAY 'ARRAY))))
(SETQ OBARRAY (SETQ COBARRAY (ARRAY () OBARRAY COBARRAY)))
(MAPC 'INTERN
'(
*EXPR *FEXPR *LEXPR @DEFINE ARRAY* CHOMPHOOK CMSGFILES
COBARRAY COMPILE COMPLR COMPLRVERNO COUTPUT CREADTABLE
DIRECTORY EOC-EVAL GENPREFIX GOFOO MACROLIST MAKLAP
MSDEV MSDIR NO-EXTRA-OBARRAY NCOMPLR NOTYPE NUMFUN
NUMVAR ONMLS OWN-SYMBOL RECOMPL SOBARRAY SPECIAL
SPLITFILE SQUID SREADTABLE SWITCHTABLE TOPLEVEL
UNDFUNS UNSPECIAL
))
(MAPC '(LAMBDA (X) (INTERN (CADR X))) SWITCHTABLE)
(AND #(SAILP) (MAPC 'INTERN '(REQUIRE EREAD CODE MAIL)))
(SETQ OBARRAY SOBARRAY)))
(SETSYNTAX '/& 'MACRO 'MACR-AMP-FUN)
#(LET ((PROP (LSUB '(MACRO SPECIAL ARGS *EXPR *FEXPR *LEXPR
NUMVAR NUMFUN *ARRAY OHOME)
L))
(Z () ))
(MAPATOMS '(LAMBDA (Y)
(LREMPROP Y PROP) ;Remove compilation
(COND ((SETQ DATA (GET Y 'FUNTYP-INFO)) ;properties.
(AND (NOT (GET Y (CAR DATA)))
(ARGS Y (CDR DATA))))
((NOT (SYSP Y)) (ARGS Y () )))
(AND (BOUNDP Y) ;SPECIALize the
(NOT (MEMQ Y '(T NIL))) ;system varialbes
(SETQ DATA Y)
(MEMQ 'VALUE (STATUS SYSTEM DATA))
(PUSH Y Z))))
(APPLY 'SPECIAL Z)
(FASLINIT))
(PUTPROP 'LET '|LET MACRO| 'MACRO)
(PUTPROP '%HUNK3 '(() . 3) 'ARGS)
(PUTPROP '%HUNK4 '(() . 4) 'ARGS)
(SETQ PRINLEVEL (SETQ PRINLENGTH (SETQ *RSET () )))
(SETQ BASE 8. IBASE 8. *NOPOINT 'T)
(SETQ COMPILATION-FLAGCONVERSION-TABLE
'((EXPR . SUBR) (FEXPR . FSUBR) (LEXPR . LSUBR)))
(SETQ SPECVARS () GENPREFIX '(/| G) GFYC 0 P1GFY ()
CLOSED () FIXSW () FLOSW () MACROLIST ()
GAG-ERRBREAKS () RNL () CFVFL ()
UNDFUNS () P1LLCEK () LAPLL () ROSENCEK ()
FASLPUSH () RECOMPL () CMSGFILES () LAP-INSIGNIF 'T
EOC-EVAL () COMPILER-STATE 'TOPLEVEL CHOMPHOOK ()
TOPFN () ONMLS () READ () MSDEV 'DSK MSDIR ()
CL () CLEANUPSPL 0 FILESCLOSEP () IMOSAR () )
#(SETUP-CATCH-PDL-COUNTS)
(MAPC '(LAMBDA (X) (SET (CADR X) (CADDR X))) SWITCHTABLE)
(MAPC '(LAMBDA (X) (SET X (COPYSYMBOL X () )))
'(PROGN GOFOO NULFU COMP CARCDR ARGLOC SQUID MAKUNBOUND))
(PUTPROP SQUID '(LAMBDA (GL) (LIST 'QUOTE GL)) 'MACRO)
(SETQ QSM (LIST (LIST 'QUOTE (LIST SQUID MAKUNBOUND))))
(SETQ STSL (LIST (STATUS STATUS) (STATUS SSTATUS)))
(SETQ ARGLOC (LIST ARGLOC) CLPROGN (LIST PROGN))
(SETQ CAAGL (LIST (LIST (CONS MAKUNBOUND ARGLOC) 1)
(LIST (CONS MAKUNBOUND ARGLOC) 2)))
(SETQ MAPSB (NCONC (MAPCAR 'LIST '(VL EXIT EXITN PVR STSL))
(LIST (CONS 'GOFOO GOFOO))))
(SETQ COMAL (SUBST '() 'NIL '((NIL . NIL) (FIXNUM . FIXNUM) (FLONUM . FLONUM) (T))) )
(RPLACD (CAR COMAL) (CAR COMAL)) ;Sets up infinite
(RPLACD (CADR COMAL) (CADR COMAL)) ; type lists for COMARITH
(RPLACD (CADDR COMAL) (CADDR COMAL))
(FIXNUM BASE IBASE BPORG BPEND TTY) ;Some known declarations
(FIXNUM (LENGTH) (RANDOM) (EXAMINE FIXNUM) (LISTEN) (RUNTIME)
(GETCHARN NOTYPE FIXNUM) (FLATSIZE) (FLATC) (LSH) (ROT) (IFIX)
(↑ FIXNUM FIXNUM) (\\ FIXNUM FIXNUM) (SXHASH) (TYIPEEK) (TYI)
(HAULONG))
(FIXNUM (IN) (LINEL) (PAGEL) (CHARPOS) (LINENUM) (PAGENUM) (LENGTHF))
(PUTPROP 'BOOLE (CONS (CADR COMAL) (CONS 'FIXNUM (CADR COMAL))) 'NUMFUN)
(FLONUM (SIN) (COS) (SQRT) (LOG) (EXP) (ATAN) (TIME)
(↑$ FLONUM FIXNUM) (FSC) (FLOAT))
(NOTYPE (GETCHAR NOTYPE FIXNUM) (CXR FIXNUM) (DEPOSIT FIXNUM))
(PUTPROP PROGN 'T '*LEXPR)
(AND #(SAILP) (*FEXPR REQUIRE EREAD CODE MAIL))
(ARRAY* (NOTYPE OBARRAY 1 READTABLE 1))
(SSTATUS TTYINT '/≡ 'INT-↑↑-FUN)
(SETQ OBARRAY ##(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'COBARRAY)
('SOBARRAY)))
(SETQ READTABLE ##(COND ((MEMQ COMPILER-STATE '(MAKLAP DECLARE)) 'CREADTABLE)
('SREADTABLE)))
(GCTWA))
;;; Function for & macro char
(DEFUN MACR-AMP-FUN ()
((LAMBDA (OBARRAY READTABLE)
(COND ((= (TYIPEEK) ##(INVERSE-ASCII '/&))
(TYI)
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)))
(READ))
COBARRAY CREADTABLE))
;;; Function for control-↑ interrupt
(DEFUN INT-↑↑-FUN N
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () N (ARG 2))
(SSTATUS TOPLEVEL '(INT-↑↑-TOPLE))
(DO () ((OR (= (LISTEN) 0) (= (TYI) N))))
(↑G))
(DEFUN INT-↑↑-TOPLE () ;Starts up MAKLAP from ↑↑
#(ERL-SET)
(SSTATUS TOPLEVEL () )
(COMPLRVERNO)
(NOINTERRUPT () )
(MAKLAP))
(DEFUN DB FEXPR (L) ;Setup for debugging
L
(SETQ SAVED-ERRLIST ERRLIST ERRLIST () )
(SSTATUS TOPLEVEL '(DB-TOPLE))
(↑G))
(DEFUN DB-TOPLE ()
(SSTATUS UUOLI)
#(ERL-SET)
(*RSET (NOUUO 'T))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE)
(SETQ ↑W (SETQ ↑R () ))
(SETQ ERRSET (FUNCTION (LAMBDA (X) X (BREAK ERRSET))))
(PROG (L)
A (COND ((NOT (GET 'BS 'FSUBR))
(COND (#(ITSP) (SETQ L '((DSK LIBLSP) BS FASL)))
((PROBEF (SETQ L '((DSK) BS FAS))))
('T (PRINC '|/
PLEASE LOAD BS FASL! /
|)
(BREAK LOAD)
(GO A)))
(LOAD L))))
(SSTATUS TOPLEVEL () ))
(DEFUN EVAL-WHEN FEXPR (L)
((LAMBDA (LOADP EVALP)
(AND (COND ((MEMQ COMPILER-STATE '(MAKLAP COMPILE))
(SETQ LOADP (MEMQ 'LOAD (CAR L))
EVALP (MEMQ 'COMPILE (CAR L)))
(OR EVALP LOADP))
;This allows for COMPILER-STATE to be () and TOPLEVEL
((SETQ EVALP (MEMQ 'EVAL (CAR L)))))
((LAMBDA (OBARRAY READTABLE)
(AND (NOT (MEMQ COMPILER-STATE '(MAKLAP COMPILE)))
(SETQ OBARRAY SOBARRAY READTABLE SREADTABLE))
(AND LOADP (MAPC 'COUTPUT (CDR L)))
(AND EVALP (MAPC 'EVAL (CDR L)))
'T)
COBARRAY CREADTABLE)))
() ()))
;This function never returns, but is a way to start up the toplevel complr
(DEFUN CDUMP N
(SETQ ERRLIST () SAVED-ERRLIST '((COMPLRVERNO)))
(SSTATUS TOPLEVEL '(COMPLR-TOPLE))
(SETQ CDUMP (LISTIFY N))
(THROW () ())
;;(COMMENT Hopefully, this goes to a TOPLEVEL user of COMPLR-TOPLE)
)
(DEFUN COMPLR-TOPLE () ;Initial TOPLEVEL loop
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE)
(SSTATUS TOPLEVEL () )
(SETQ - () + () )
#(ERL-SET)
(GCTWA 1)
(GC)
(APPLY 'SUSPEND CDUMP)
#(LET ((UID (STATUS USERID))
(USN (COND ((STATUS STATUS HOMED) (STATUS HOMED)) ((STATUS UDIR))))
(MSGFILES '(T)) FILE OFILE)
(SETQ OFILE (CONS (LIST 'DSK USN)
(COND (#(ITSP) (CONS UID '(COMPLR)))
('(COMPLR INI))))) ;`((DSK ,usn) ,uid COMPLR)
(AND (COND ((SETQ FILE (PROBEF OFILE)))
(#(ITSP)
(RPLACA (CDR OFILE) '*)
(AND (SETQ FILE (CAR (ERRSET (OPEN OFILE '(NODEFAULT)) () )))
(SETQ FILE (TRUENAME FILE)))
FILE))
(PRINC '|LOADING COMPLR INITIALIZATION FILE FOR |)
(PRINC (COND ((OR (EQ (CADR OFILE) '*) (NOT #(ITSP))) USN)
(UID)))
(PROG2 (TERPRI) 'T)
(AND (ATOM (ERRSET (LOAD FILE) 'T))
(PRINC '| *** ERRORS DURING LOADING *** BEWARE!| TYO)))
(SETQ DEFAULTF (MERGEF '(FOO) (CONS (CAR OFILE)
(CONS '* (COND (#(ITSP) '>)
(#(SAILP) '|←←←|)
('LSP))))))
(COND ((SETQ DATA (STATUS JCL))
(LET (WINP (JCL-LINE DATA))
(SETQ WINP
(ERRSET
(PROG (M L LL)
(SETQ L DATA)
A (AND (< (SETQ M (GETCHARN (CAR L) 1)) 27.) ;Flush control chars
(NOT (= M 17.)) ;[except ↑Q] from
(SETQ L (CDR L)) ;front of JCL list
(GO A))
(SETQ LL ())
B (SETQ M (GETCHARN (CAR L) 1))
(PUSH (COND ((AND (< M 123.) (> M 96.))
(- M 32.)) ;Uppercaseify rest
(M)) ;of line
LL)
(AND (SETQ L (CDR L)) (GO B))
C (AND (< (CAR LL) 27.)
(SETQ LL (CDR LL)) ;Flush control chars
(GO C)) ;from end of line
(APPLY 'MAKLAP (NREVERSE LL)))
'T ))
(COND ((ATOM WINP)
(COND (WINP (PRINC '| *** ERRORS FROM JCL COMMAND *** /
;JCL = "|)
(PRINC (MAKNAM JCL-LINE))
(PRINC '|"/
|)
(BREAK JCL))
('T (PRINC '| *** ERRORS - RANDOMNESS IN COMPLR-TOPLE|)
(BREAK COMPLR-TOPLE))) ))
(INT-↑↑-TOPLE)))
('T (COMPLRVERNO) (MAKLAP)))) )
;;; NOTE: THE LIST OF GLOBALSYMS SHOULD CORRESPOND TO
;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP.
(DEFUN FASLINIT ()
(GETMIDASOP ())
((LAMBDA (OBARRAY PROPS ACS FL)
(MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS)))
(SETQ LDFNM (FASLAPSETUP/| () )) ;Sets up GLOBALSYMS
(COND ((AND (BOUNDP 'COBARRAY)
(EQ (TYPEP COBARRAY) 'ARRAY)
(SETQ FL (ARRAYDIMS COBARRAY))
(EQ (CAR FL) 'OBARRAY)
(NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY))))
(SETQ FL '(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL
ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM
THIS IS THE UNFASL FOR LISP FILE COMPILED BY COMPILER))
(MAPATOMS '(LAMBDA (X) (AND (GETL X '(SYM GLOBALSYM)) (PUSH X FL))))
;;;AFTER THE FASLAPSETUP/|, ONLY SYMS SHOULD BE GLOBALSYMS. IN ORDER:
;*SET *MAP PRINTA SPECBIND UNBIND IOGBND *LCALL *UDT ARGLOC
;INUM ST FXNV1 PDLNMK PDLNKJ FIX1A FIX1 FLOAT1 IFIX IFLOAT
;FXCONS FLCONS ERSETUP ERUNDO GOBRK CARCDR *STORE NPUSH PA3
;MAKUNBOUND FLTSKP FXNV2 FXNV3 FXNV4 FIX2 FLOAT2 AREGET
;UINITA UTIN INTREL INHIBIT NOQUIT CHECKI 0PUSH 0*0PUSH
;NILPROPS VBIND %CXR %RPX
(SETQ OBARRAY COBARRAY)
(MAPC 'INTERN FL) ;CROSS-INTERNS GLOBALSYMS
(MAPC 'INTERN (APPEND PROPS ACS))) ;PLUS A FEW OTHER WORDS
(T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE)))
(SETQ SQUIDP ()) ;LISTS AND SET UP GLOBALSYMS
(DO ((I 0 (1+ I)) (L ACS (CDR L))) ;NOW DEFINE SYMS FOR LISP ACS
((NULL L))
(AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM)))
(ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.)
(ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.)
(DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((() -1)))))
(SETQ IMOSAR () IMOUSR ())
(SSTATUS FEATURE FASLAP)
(GCTWA))
OBARRAY
'(SYM ATOMINDEX ARGSINFO ENTRY GLOBALSYM)
'(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP)
()))
(COMMENT FILL INITIAL ARRAYS)
(ARRAY AC-ADDRS T ##(+ (NUMVALAC) (NUMNACS) 1))
(ARRAY PDL-ADDRS T 3 ##(+ 1 (NPDL-ADDRS)))
(ARRAY STGET T ##(+ (NUMVALAC) (NUMNACS)))
(ARRAY BOLA T ##(+ (NACS) (NUMNACS) 1) 7)
(ARRAY CBA T 16.)
(ARRAY A1S1A T ##(NUMNACS) 4)
(ARRAY PVIA T 3 (1+ (MAX ##(MAX-NPUSH) ##(MAX-0PUSH) ##(MAX-0*0PUSH))))
(PROGN (DO CNT ##(+ (NUMVALAC) (NUMNACS)) (1- CNT) (< CNT 1) ;Sets AC-ADDRS
(STORE (AC-ADDRS CNT) CNT))
(DO CNT ##(NPDL-ADDRS) (1- CNT) (< CNT 1) ;Sets PDL-ADDRS
(STORE (PDL-ADDRS 0 CNT) (- CNT ##(NPDL-ADDRS)))
(STORE (PDL-ADDRS 1 CNT) (- (+ CNT ##(FXP0)) ##(NPDL-ADDRS)))
(STORE (PDL-ADDRS 2 CNT) (- (+ CNT ##(FLP0)) ##(NPDL-ADDRS))))
;;; (STGET n) is for accessing segment table into register n
(DO CNT ##(+ (NUMVALAC) (NUMNACS) -1) (1- CNT) (< CNT 1)
(STORE (STGET CNT) (SUBST CNT 'N '(0 ST N))))
(DO ((HLAC ##(+ (NACS) (NUMNACS)) (1- HLAC))
(ATPL (SUBST ##(NUMVALAC) 'AC '((TDZA N N)
(MOVEI N 'T)
(SKIPE 0 N)
(MOVNI AC N)
(MOVEI N '() )
(SKIPN 0 N) ))))
((< HLAC 1))
(DO ((CNT 1 (1+ CNT)) (ATPL1 ATPL (CDR ATPL1)))
((NULL ATPL1))
(STORE (BOLA HLAC CNT) (SUBST HLAC 'N (CAR ATPL1)))))
(FILLARRAY 'CBA '((SETZ) (AND) (ANDCA) (SETA) ;Sets CBA
(ANDCM) (SETM) (XOR) (IOR) (ANDCB)
(EQV) (SETCM) (ORCA) (SETCA)
(ORCM) (ORCB) (SETO)))
(DO CNT ##(- (NUMNACS) 1) (1- CNT) (< CNT 0) ;Sets A1S1A
(DO ((HLAC 0 (1+ HLAC)) (L '((ADDI 1)
(SUBI 1)
(FADRI 66304.) ;66304. = 201400[8]
(FSBRI 66304.))
(CDR L)))
((NULL L))
(STORE (A1S1A CNT HLAC) (LIST (CAAR L)
(+ CNT ##(NUMVALAC))
(CADAR L)))))
;;; Makes up array of JSPs to places that push the appropriate number
;;; of pdl-variable initialization values, onto the appropriate stack.
;;; (PVIA 0 n) ==> (JSP T (NPUSH -n)) pushes ()s onto REGPDL
;;; (PVIA 1 n) ==> (JSP T (0PUSH -n)) pushes 0s onto FXPDL
;;; (PVIA 2 n) ==> (JSP T (0*0PUSH -n)) pushes 0.0s onto FLPDL
(STORE (PVIA 0 0) ##(MAX-NPUSH))
(STORE (PVIA 1 0) ##(MAX-0PUSH))
(STORE (PVIA 2 0) ##(MAX-0*0PUSH))
(STORE (PVIA 0 1) '(PUSH P (% 0 0 '())))
(STORE (PVIA 1 1) '(PUSH FXP (% 0)))
(STORE (PVIA 2 1) '(PUSH FLP (% 0.0)))
(STORE (PVIA 0 2) 'NPUSH)
(STORE (PVIA 1 2) '0PUSH)
(STORE (PVIA 2 2) '0*0PUSH)
(DO CNT 0 (1+ CNT) (> CNT 2)
(DO HLAC (PVIA CNT 0) (1- HLAC) (< HLAC 3)
(STORE (PVIA CNT HLAC) (LIST 'JSP 'T (LIST (PVIA CNT 2) (- HLAC))))))
(COND (*PURE
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(STORE (ARRAYCALL T GL CNT)
(PURCOPY (ARRAYCALL T GL CNT)))))
'(AC-ADDRS STGET CBA))
(MAPC '(LAMBDA (GL)
(SETQ GL (GET GL 'ARRAY))
(DO CNT (1- (CADR (ARRAYDIMS GL))) (1- CNT) (< CNT 0)
(DO HLAC (1- (CADDR (ARRAYDIMS GL)))
(1- HLAC)
(< HLAC 0)
(STORE (ARRAYCALL T GL CNT HLAC)
(PURCOPY (ARRAYCALL T GL CNT HLAC))))))
'(PDL-ADDRS BOLA A1S1A PVIA))))
)
(COMMENT PUT PROPERTIES ON VARIOUS SYMBOLS)
(PROGN (DEFPROP RPLACD (HRRM . HRRM) INST)
(DEFPROP RPLACA (HRLM . HRLM) INST)
(DEFPROP RPLACD (HLLZS . HLLZS) INSTN)
(DEFPROP RPLACA (HRRZS . HRRZS) INSTN)
(DEFPROP SETPLIST (HRRM . HRRM) INST)
(DEFPROP SETPLIST (HLLZS . HLLZS) INSTN)
(DEFPROP A (HLRZ . HLRZ) INST)
(DEFPROP D (HRRZ . HRRZ) INST)
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'IMMED))
'(MOVE CAMN CAME
ADD SUB IMUL IDIV CAMLE CAMG CAML CAMGE MOVN
AND ORCB SETCM XOR EQV IOR ANDCB ANDCA ANDCM ORCM ORCA)
'(MOVEI CAIN CAIE
ADDI SUBI IMULI IDIVI CAILE CAIG CAIL CAIGE MOVNI
ANDI ORCBI SETCMI XORI EQVI IORI ANDCBI ANDCAI ANDCMI ORCMI ORCAI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'JSP))
'(CONS XCONS NCONS %HUNK3 %HUNK4)
'(
(((JSP T %CONS) .
(JSP T %C2NS))
. ((JSP T %PDLC) .
(JSP T %C2NS)))
(((JSP T %XCONS) .
(JSP T %PDLXC))
. PUNT )
(((JSP T %NCONS)) .
((JSP T %PDLNC)))
((JSP T %HUNK3))
((JSP T %HUNK4))
))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'COMMU) (PUTPROP INSTN INST 'COMMU))
'(CONS *GREAT *PLUS *TIMES EQUAL CAMG CAMGE JUMPGE JUMPL)
'(XCONS *LESS *PLUS *TIMES EQUAL CAML CAMLE JUMPLE JUMPG))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'CONV) (PUTPROP INSTN INST 'CONV))
'(JUMP JUMPL JUMPE JUMPLE TRNN TLNN SOJE CAMG CAML
CAMN CAIG CAIL CAIE SKIPE SKIPG SKIPL)
'(JUMPA JUMPGE JUMPN JUMPG TRNE TLNE SOJN CAMLE CAMGE
CAME CAILE CAIGE CAIN SKIPN SKIPLE SKIPGE))
;A status option with no STATUS property means no evaluation of its
; entries. "(x . y)" means "x" is for sstatus and "y" for status;
; x and y are "A" to mean evaluate all but option name, and "B" to
; mean evaluate all but option name and next thing.
(MAPC '(LAMBDA (Z Y) (MAPC '(LAMBDA (X) (PUTPROP X Z 'STATUS)) Y))
'((A . A) (() . A) (A . () ) (B . B))
'((TTY TTYRE TTYTY TTYCO TTYSC TTYIN LINMO TERPR PDLMA INTER
GCMIN GCSIZ GCMAX)
(DIVOV FTVSI + TOPLE UUOLI ABBRE GCTIM GCWHO WHO1 WHO2 WHO3
EVALH BREAK MAR CLI FLUSH PUNT RANDO /← LOSEF)
(SYSTE SPCSI PURSI PDLSI PDLRO FILEM TTYSI OSPEE)
(MACRO SYNTA CHTRA)))
((LAMBDA (EXLDL GL) (FUNCALL EXLDL () () ))
'(LAMBDA (CARCDR LDLST)
((LAMBDA (EXIT EXITN)
(PUTPROP EXIT (CONS 'A (CONS CARCDR (CAR GL))) 'CARCDR)
(PUTPROP EXITN (CONS 'D (CONS CARCDR (CADR GL))) 'CARCDR)
(SETQ GL (CDDR GL))
(COND ((< (LENGTH LDLST) 3)
(FUNCALL EXLDL EXIT (CONS 'A LDLST))
(FUNCALL EXLDL EXITN (CONS 'D LDLST)))))
(IMPLODE (APPEND '(C A) LDLST '(R)))
(IMPLODE (APPEND '(C D) LDLST '(R)))))
'(6. 14. 5. 13. 19. 24. 27. 33. 36. 30. 3. 11. 17. 22. 1. 9.
4. 12. 18. 23. 26. 32. 35. 29. 2. 10. 16. 21. 0. 8.)) ;BOY! ARE THESE NUMBERS RANDOM!
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'MINUS))
'(MOVEI ADDI SUBI)
'(MOVNI SUBI ADDI))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'BOTH))
'(ADD SUB IMUL IDIV FADR FSBR FDVR FMPR)
'(ADDB SUBB IMULB IDIVB FADRB FSBRB FDVRB FMPRB))
(MAPC '(LAMBDA (INST INSTN) (PUTPROP INST INSTN 'FLOATI))
'(FADR FSBR FMPR FDVR MOVE)
'(FADRI FSBRI FMPRI FDVRI MOVSI))
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(AND (CDDR X) (ARGS (CAR X) (CDDR X)))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((ALLFILES SUBR () . 1)
(CGOL FSUBR) (CGOLREAD LSUBR) (CREATE-JOB LSUBR 3 . 5)
(DIRECTORY LSUBR 1 . 2) (FORMAT LSUBR)
(DUMPARRAYS SUBR () . 2) (GETMIDASOP SUBR () . 1)
(GRIND FSUBR) (GRIND0 FSUBR) (GRINDEF FSUBR)
(INDEX) (INF-EDIT)
(LAP FSUBR) (LAP-A-LIST SUBR () . 1)
(LEDIT FSUBR) (LOADARRAYS SUBR () . 1)
(MAPALLFILES SUBR () . 2) (MAPDIRECTORY LSUBR 2 . 3)
(SORT SUBR () . 2) (SORTCAR SUBR () . 2)
(SPRINTER SUBR () . 1) (TRACE FSUBR)
))
(AND (STATUS FEATURE SAIL)
(MAPC '(LAMBDA (X)
(COND ((GET (CAR X) 'AUTOLOAD)
(AND (CDDR X) (ARGS (CAR X) (CDDR X)))
(AND (CDR X) (PUTPROP (CAR X) (CDR X) 'FUNTYP-INFO)))))
'((EREAD FSUBR) (EOPEN LSUBR 0 . 4) (UGREAT1 SUBR () . 1)
(EDIT FSUBR) (CODE FSUBR) (MAIL FSUBR))))
(DEFPROP %CATCHALL (FSUBR) FUNTYP-INFO)
(DEFPROP %PASS-THRU (FSUBR) FUNTYP-INFO)
(MAPC '(LAMBDA (X) (PUTPROP X 'NOTNUMP 'NOTNUMP)) ;Has no side-effects
'(
%HUNK3 %HUNK4 *APPEND ALPHALESSP
APPEND ARRAYDIMS ASSOC ASSQ ATOM BAKLIST
BIGP BOUNDP CONS COPYSYMBOL ERRFRAME
EVALFRAME EXPLODE EXPLODEC EXPLODEN
FILEP FIXP FLOATP GETCHAR GETL HUNK
HUNKP LAST LISTARRAY LISTIFY MAKNAM
MEMBER MEMQ NCONS NTHCDR NULL NUMBERP
PLIST PNGET REVERSE SAMEPNAMEP SIGNP
SUBLIS SUBST SYMBOLP SYSP TYPEP XCONS
))
(MAPC '(LAMBDA (X) (PUTPROP X 'EFFS 'NOTNUMP)) ;Has side-effects
'(
*ARRAY *DELETE *DELQ *NCONC *READCH *REARRAY
ALARMCLOCK ASCII CURSORPOS DELETE DELQ DUMPARRAYS
FILLARRAY GENSYM IMPLODE INTERN LOADARRAYS NCONC NRECONC
NREVERSE READCH REMOB REMPROP SASSOC SASSOC SASSQ SETPLIST
SETSYNTAX SORT SORTCAR SUSPEND TERPRI VALRET
))
(MAPC '(LAMBDA (X) (PUTPROP X 'T 'NOTNUMP)) ;Has side-effects, and returns T
'(TYO /+TYO *TYO DEPOSIT PRIN1 PRINC PRINT *PRIN1 *PRINC *PRINT))
;;; In general, function-names with ACS properties have no side-effects, except
;;; for those explicity mentioned under the NOTNUMP property above. Thus
;;; (NOT (GET x 'ACS)) is a general test for potentially-random side-effects.
(MAPC '(LAMBDA (DATA)
(MAPC '(LAMBDA (X) (AND (SYSP X) (PUTPROP X (CADAR DATA) (CAAR DATA))))
(CDR DATA)))
'(
((ACS 1) IN OUT CLOSE LINEL PAGEL CHARPOS LINENUM PAGENUM
CLEAR-INPUT CLEAR-OUTPUT FORCE-OUTPUT NAMELIST
TRUENAME PROBEF DELETEF DEFAULTF FASLP)
((ACS 2) MERGEF)
((ACS 3) NAMESTRING SHORTNAMESTRING)
((ACS 4) RUBOUT RENAMEF ENDPAGEFN EOFFN FILEP DELETEF FILEPOS
LENGTHF CNAMEF)
((ACS 5) OPEN)
;Missing are INCLUDE and LOAD, because they may cause
; totally unforseen side-effects
((ACS 1) LENGTH ADD1 SUB1 MINUS ABS FLOAT FIX
SIN COS SQRT LOG EXP ZEROP PLUSP MINUSP ODDP
1+ 1- 1+/$ 1-/$)
((ACS 1) LAST SLEEP RANDOM NOINTERRUPT EXAMINE
ARG MUNKAM ERRFRAME)
((ACS 2) PLUS TIMES EXPT DIFFERENCE QUOTIENT MAX MIN
GREATERP LESSP ATAN
*PLUS *TIMES *GREAT *QUO *DIF *LESS /\/\ /↑ /↑$
HAULONG HAIPART GCD BOOLE REMAINDER)
((ACS 2) GET REMPROP MEMQ RECLAIM EQUAL DEPOSIT
CONS NCONS XCONS SUBLIS NCONC *NCONC *DELQ
DELQ ASSQ ALARMCLOCK SETARG SETPLIST MAKNUM
SAMEPNAMEP ALPHALESSP GETCHARN MAKNAM LISTIFY
NTH NTHCDR)
((ACS 3) GENSYM FLATSIZE FLATC PNGET EVALFRAME PURIFY
LISTARRAY FILLARRAY DUMPARRAYS ARRAYDIMS
PRINT PRIN1 PRINC *PRINT *PRIN1 *PRINC
SYSP COPYSYMBOL SXHASH
REVERSE NREVERSE NRECONC GETL PUTPROP ARGS)
((ACS 4) ASSOC SASSOC SASSQ CRUNIT)
((ACS 4) %HUNK3 %HUNK4)
((ACS 5) SUBST *DELETE DELETE MEMBER *APPEND APPEND
*ARRAY *REARRAY LOADARRAYS
BAKTRACE BAKLIST ERRPRINT
ALLOC *FUNCTION SUSPEND SETSYNTAX
EXPLODEC EXPLODE EXPLODEN
PNPUT INTERN IMPLODE REMOB ASCII READCH *READCH
*TERPRI TERPRI *TYO TYO /+TYO *TYI TYI TYIPEEK
CURSORPOS
GETMIDASOP GETDDTSYM PUTDDTSYM
UREAD UWRITE UKILL UFILE UPROBE UCLOSE UAPPEND
)))
;EVAL, *EVAL, READ, *READ and MAP series aren't here, since
; they permint random evaluations [hence random side effects]
;PAGEBPORG isn't here since it setqs BPORG, and may cause a GC.
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'P1BOOL1ABLE))
'(AND OR NULL NOT EQ = > < COND MEMQ SIGNP))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NUMBERP 'P1BOOL1ABLE))
'(EQUAL GREATERP LESSP ODDP *GREAT *LESS ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (INST INSTN)
(PUTPROP INST
(CONS (CONS 'TLNN INSTN) (CONS 'TLNE INSTN))
'P1BOOL1ABLE))
'(ATOM NUMBERP FIXP FLOATP BIGP HUNKP SYMBOLP)
;(175700 161400 121000 40400 20000 20 10000)
'(64448. 58112. 41472. 16640. 8192. 16. 4096.))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'CONTAGIOUS))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'T 'NUMBERP))
'(PLUS TIMES DIFFERENCE QUOTIENT *PLUS *TIMES *DIF *QUO
ABS MINUS FIX FLOAT IFIX ADD1 SUB1 REMAINDER HAULONG))
(MAPC '(LAMBDA (INST) (PUTPROP INST 'NOTYPE 'NUMBERP))
'(GREATERP LESSP *GREAT *LESS EQ EQUAL ODDP ZEROP PLUSP MINUSP))
(MAPC '(LAMBDA (X) (PUTPROP (CAR X) (CDR X) 'ARITHP))
'( (/+ PLUS FIXNUM) (+$ PLUS FLONUM)
(/- DIFFERENCE FIXNUM) (-$ DIFFERENCE FLONUM)
(/* TIMES FIXNUM) (*$ TIMES FLONUM)
(/1+ ADD1 FIXNUM) (1+$ ADD1 FLONUM)
(/1- SUB1 FIXNUM) (1-$ SUB1 FLONUM)
(// QUOTIENT FIXNUM) (//$ QUOTIENT FLONUM)
(/> GREATERP () ) (/< LESSP () )
(/\ REMAINDER FIXNUM) (/= EQUAL () )))
)
β